#!/usr/bin/env perl
# This script is used to test Mongoose web server
# $Id: test.pl 430 2009-06-29 07:40:15Z valenok $

use IO::Socket;
use File::Path;
use strict;
use warnings;
#use diagnostics;

sub on_windows { $^O =~ /win32/i; }

my $port = 23456;
my $pid = undef;
my $num_requests;
my $root = 'test';
my $dir_separator = on_windows() ? '\\' : '/';
my $copy_cmd = on_windows() ? 'copy' : 'cp';
my $test_dir_uri = "test_dir";
my $test_dir = $root . $dir_separator. $test_dir_uri;
my $alias = "/aliased=/etc/,/ta=$test_dir";
my $config = 'mongoose.conf';
my $exe = '.' . $dir_separator . 'mongoose';
my $embed_exe = '.' . $dir_separator . 'embed';
my $unit_test_exe = '.' . $dir_separator . 'unit_test';
my $exit_code = 0;

my @files_to_delete = ('debug.log', 'access.log', $config, "$root/put.txt",
	"$root/a+.txt", "$root/.htpasswd", "$root/binary_file",
       	$embed_exe, $unit_test_exe);

END {
	unlink @files_to_delete;
	kill_spawned_child();
	File::Path::rmtree($test_dir);
	exit $exit_code;
}

sub fail {
	print "FAILED: @_\n";
	$exit_code = 1;
	exit 1;
}

sub get_num_of_log_entries {
	open FD, "access.log" or return 0;
	my @logs = (<FD>);
	close FD;
	return scalar @logs;
}

# Send the request to the 127.0.0.1:$port and return the reply
sub req {
	my ($request, $inc) = @_;
	my $sock = IO::Socket::INET->new(Proto=>"tcp",
		PeerAddr=>'127.0.0.1', PeerPort=>$port);
	fail("Cannot connect: $!") unless $sock;
	$sock->autoflush(1);
	foreach my $byte (split //, $request) {
		last unless print $sock $byte;
		select undef, undef, undef, .001 if length($request) < 256;
	}
	my @lines = <$sock>;
	my $out = join '', @lines;
	close $sock;

	$num_requests += defined($inc) ? $inc : 1;
	my $num_logs = get_num_of_log_entries();

	unless ($num_requests == $num_logs) {
		fail("Request has not been logged: [$request]")
	}

	return $out;
}

# Send the request. Compare with the expected reply. Fail if no match
sub o {
	my ($request, $expected_reply, $message, $num_logs) = @_;
	print "==> Testing $message ... ";
	my $reply = req($request, $num_logs);
	if ($reply =~ /$expected_reply/s) {
		print "OK\n";
	} else {
		fail("Requested: [$request]\n".
			"Expected: [$expected_reply], got: [$reply]");
	}
}

# Spawn a server listening on specified port
sub spawn {
	my ($cmdline) = @_;
	if (on_windows()) {
		my @args = split /\s+/, $cmdline;
		my $executable = $args[0];
		$executable .= '.exe';
		Win32::Spawn($executable, $cmdline, $pid);
		die "Cannot spawn @_: $!" unless $pid;
	} else {
		unless ($pid = fork()) {
			exec $cmdline;
			die "cannot exec [$cmdline]: $!\n";
		}
	}
	sleep 1;
}

sub write_file {
	open FD, ">$_[0]" or fail "Cannot open $_[0]: $!";
	binmode FD;
	print FD $_[1];
	close FD;
}

sub read_file {
	open FD, $_[0] or fail "Cannot open $_[0]: $!";
	my @lines = <FD>;
	close FD;
	return join '', @lines;
}

sub kill_spawned_child {
	if (defined($pid)) {
		kill(9, $pid);
		waitpid($pid, 0);
	}
}

####################################################### ENTRY POINT

unlink @files_to_delete;
$SIG{PIPE} = 'IGNORE';
#local $| =1;

# Make sure we export only symbols that start with "mg_", and keep local
# symbols static.
if ($^O =~ /darwin|bsd|linux/) {
	my $out = `(cc -c mongoose.c && nm mongoose.o) | grep ' T '`;
	foreach (split /\n/, $out) {
		/T\s+_?mg_.+/ or fail("Exported symbol $_")
	}
}

if (scalar(@ARGV) > 0 and $ARGV[0] eq 'embedded') {
	do_embedded_test();
	exit 0;
} elsif (scalar(@ARGV) > 0 and $ARGV[0] eq 'unit') {
	do_unit_test();
	exit 0;
}

# Make sure we load config file if no options are given
write_file($config, "ports 12345\naccess_log access.log\n");
spawn($exe);
my $saved_port = $port;
$port = 12345;
o("GET /test/hello.txt HTTP/1.0\n\n", 'HTTP/1.1 200 OK', 'Loading config file');
$port = $saved_port;
unlink $config;
kill_spawned_child();

do_unit_test();

# Spawn the server on port $port
my $cmd = "$exe -ports $port -access_log access.log -error_log debug.log ".
		"-cgi_env CGI_FOO=foo,CGI_BAR=bar,CGI_BAZ=baz " .
		"-mime_types .bar=foo/bar,.tar.gz=blah,.baz=foo " .
		"-root test -aliases $alias -admin_uri /hh";
$cmd .= ' -cgi_interp perl' if on_windows();
spawn($cmd);

# Try to overflow: Send very long request
req('POST ' . '/..' x 100 . 'ABCD' x 3000 . "\n\n", 0); # don't log this one

o("GET /hello.txt HTTP/1.0\n\n", 'HTTP/1.1 200 OK', 'GET regular file');
o("GET /hello.txt HTTP/1.0\n\n", 'Content-Length: 17\s',
	'GET regular file Content-Length');
o("GET /%68%65%6c%6c%6f%2e%74%78%74 HTTP/1.0\n\n",
	'HTTP/1.1 200 OK', 'URL-decoding');

# '+' in URI must not be URL-decoded to space
write_file("$root/a+.txt", '');
o("GET /a+.txt HTTP/1.0\n\n", 'HTTP/1.1 200 OK', 'URL-decoding, + in URI');

o("GET /hh HTTP/1.0\n\n", 'HTTP/1.1 200 OK', 'GET admin URI');

# Test HTTP version parsing
o("GET / HTTPX/1.0\r\n\r\n", '400 Bad Request', 'Bad HTTP Version', 0);
o("GET / HTTP/x.1\r\n\r\n", '400 Bad Request', 'Bad HTTP maj Version', 0);
o("GET / HTTP/1.1z\r\n\r\n", '400 Bad Request', 'Bad HTTP min Version', 0);
o("GET / HTTP/02.0\r\n\r\n", '505 HTTP version not supported',
	'HTTP Version >1.1');

# File with leading single dot
o("GET /.leading.dot.txt HTTP/1.0\n\n", 'abc123', 'Leading dot 1');
o("GET /...leading.dot.txt HTTP/1.0\n\n", 'abc123', 'Leading dot 2');
o("GET /../\\\\/.//...leading.dot.txt HTTP/1.0\n\n", 'abc123', 'Leading dot 3');
o("GET .. HTTP/1.0\n\n", '400 Bad Request', 'Leading dot 4', 0);

mkdir $test_dir unless -d $test_dir;
o("GET /$test_dir_uri/not_exist HTTP/1.0\n\n",
	'HTTP/1.1 404', 'PATH_INFO loop problem');
o("GET /$test_dir_uri HTTP/1.0\n\n", 'HTTP/1.1 301', 'Directory redirection');
o("GET /$test_dir_uri/ HTTP/1.0\n\n", 'Modified', 'Directory listing');
write_file("$test_dir/index.html", "tralala");
o("GET /$test_dir_uri/ HTTP/1.0\n\n", 'tralala', 'Index substitution');
o("GET / HTTP/1.0\n\n", 'embed.c', 'Directory listing - file name');
o("GET /ta/ HTTP/1.0\n\n", 'Modified', 'Aliases');
o("GET /not-exist HTTP/1.0\r\n\n", 'HTTP/1.1 404', 'Not existent file');
mkdir $test_dir . $dir_separator . 'x';
my $path = $test_dir . $dir_separator . 'x' . $dir_separator . 'index.cgi';
write_file($path, read_file($root . $dir_separator . 'env.cgi'));
chmod 0755, $path;
o("GET /$test_dir_uri/x/ HTTP/1.0\n\n", "Content-Type: text/html\r\n\r\n",
		'index.cgi execution');

my $mime_types = {
	html => 'text/html',
	htm => 'text/html',
	txt => 'text/plain',
	unknown_extension => 'text/plain',
	js => 'application/x-javascript',
	css => 'text/css',
	jpg => 'image/jpeg',
	c => 'text/plain',
	'tar.gz' => 'blah',
	bar => 'foo/bar',
	baz => 'foo',
};

foreach my $key (keys %$mime_types) {
	my $filename = "_mime_file_test.$key";
	write_file("$root/$filename", '');
	o("GET /$filename HTTP/1.0\n\n",
		"Content-Type: $mime_types->{$key}", ".$key mime type");
	unlink "$root/$filename";
}

# Get binary file and check the integrity
my $binary_file = 'binary_file';
my $f2 = '';
foreach (0..123456) { $f2 .= chr(int(rand() * 255)); }
write_file("$root/$binary_file", $f2);
my $f1 = req("GET /$binary_file HTTP/1.0\r\n\n");
while ($f1 =~ /^.*\r\n/) { $f1 =~ s/^.*\r\n// }
$f1 eq $f2 or fail("Integrity check for downloaded binary file");

my $range_request = "GET /hello.txt HTTP/1.1\nConnection: close\n".
		"Range: bytes=3-5\r\n\r\n";
o($range_request, '206 Partial Content', 'Range: 206 status code');
o($range_request, 'Content-Length: 3\s', 'Range: Content-Length');
o($range_request, 'Content-Range: bytes 3-5/17', 'Range: Content-Range');
o($range_request, '\nple$', 'Range: body content');

# Test directory sorting. Sleep between file creation for 1.1 seconds,
# to make sure modification time are different.
mkdir "$test_dir/sort";
write_file("$test_dir/sort/11", 'xx');
select undef, undef, undef, 1.1;
write_file("$test_dir/sort/aa", 'xxxx');
select undef, undef, undef, 1.1;
write_file("$test_dir/sort/bb", 'xxx');
select undef, undef, undef, 1.1;
write_file("$test_dir/sort/22", 'x');

o("GET /$test_dir_uri/sort/?n HTTP/1.0\n\n",
	'200 OK.+>11<.+>22<.+>aa<.+>bb<',
	'Directory listing (name, ascending)');
o("GET /$test_dir_uri/sort/?nd HTTP/1.0\n\n",
	'200 OK.+>bb<.+>aa<.+>22<.+>11<',
	'Directory listing (name, descending)');
o("GET /$test_dir_uri/sort/?s HTTP/1.0\n\n",
	'200 OK.+>22<.+>11<.+>bb<.+>aa<',
	'Directory listing (size, ascending)');
o("GET /$test_dir_uri/sort/?sd HTTP/1.0\n\n",
	'200 OK.+>aa<.+>bb<.+>11<.+>22<',
	'Directory listing (size, descending)');
o("GET /$test_dir_uri/sort/?d HTTP/1.0\n\n",
	'200 OK.+>11<.+>aa<.+>bb<.+>22<',
	'Directory listing (modification time, ascending)');
o("GET /$test_dir_uri/sort/?dd HTTP/1.0\n\n",
	'200 OK.+>22<.+>bb<.+>aa<.+>11<',
	'Directory listing (modification time, descending)');

unless (scalar(@ARGV) > 0 and $ARGV[0] eq "basic_tests") {
	# Check that .htpasswd file existence trigger authorization
	write_file("$root/.htpasswd", '');
	o("GET /hello.txt HTTP/1.1\n\n", '401 Unauthorized',
		'.htpasswd - triggering auth on file request');
	o("GET / HTTP/1.1\n\n", '401 Unauthorized',
		'.htpasswd - triggering auth on directory request');
	unlink "$root/.htpasswd";

	o("GET /env.cgi HTTP/1.0\n\r\n", 'HTTP/1.1 200 OK', 'GET CGI file');
	o("GET /sh.cgi HTTP/1.0\n\r\n", 'shell script CGI',
			'GET sh CGI file') unless on_windows();
	o("GET /env.cgi?var=HELLO HTTP/1.0\n\n", 'QUERY_STRING=var=HELLO',
		'QUERY_STRING wrong');
	o("POST /env.cgi HTTP/1.0\r\nContent-Length: 9\r\n\r\nvar=HELLO",
		'var=HELLO', 'CGI POST wrong');
	o("POST /env.cgi HTTP/1.0\r\nContent-Length: 9\r\n\r\nvar=HELLO",
	'\x0aCONTENT_LENGTH=9', 'Content-Length not being passed to CGI');
	o("GET /env.cgi HTTP/1.0\nMy-HdR: abc\n\r\n",
		'HTTP_MY_HDR=abc', 'HTTP_* env');
	o("GET /env.cgi HTTP/1.0\n\r\nSOME_TRAILING_DATA_HERE",
		'HTTP/1.1 200 OK', 'GET CGI with trailing data');

	o("GET /env.cgi%20 HTTP/1.0\n\r\n",
		'HTTP/1.1 404', 'CGI Win32 code disclosure (%20)');
	o("GET /env.cgi%ff HTTP/1.0\n\r\n",
		'HTTP/1.1 404', 'CGI Win32 code disclosure (%ff)');
	o("GET /env.cgi%2e HTTP/1.0\n\r\n",
		'HTTP/1.1 404', 'CGI Win32 code disclosure (%2e)');
	o("GET /env.cgi%2b HTTP/1.0\n\r\n",
		'HTTP/1.1 404', 'CGI Win32 code disclosure (%2b)');
	o("GET /env.cgi HTTP/1.0\n\r\n", '\nHTTPS=off\n', 'CGI HTTPS');
	o("GET /env.cgi HTTP/1.0\n\r\n", '\nCGI_FOO=foo\n', '-cgi_env 1');
	o("GET /env.cgi HTTP/1.0\n\r\n", '\nCGI_BAR=bar\n', '-cgi_env 2');
	o("GET /env.cgi HTTP/1.0\n\r\n", '\nCGI_BAZ=baz\n', '-cgi_env 3');

	# Check that CGI's current directory is set to script's directory
	my $copy_cmd = on_windows() ? 'copy' : 'cp';
	system("$copy_cmd $root" . $dir_separator .  "env.cgi $test_dir" .
	     $dir_separator . 'env.cgi');
	o("GET /$test_dir_uri/env.cgi HTTP/1.0\n\n",
		"CURRENT_DIR=.*$root/$test_dir_uri", "CGI chdir()");

	# SSI tests
	o("GET /ssi1.shtml HTTP/1.0\n\n",
		'ssi_begin.+CFLAGS.+ssi_end', 'SSI #include file=');
	o("GET /ssi2.shtml HTTP/1.0\n\n",
		'ssi_begin.+Unit test.+ssi_end', 'SSI #include virtual=');
	my $ssi_exec = on_windows() ? 'ssi4.shtml' : 'ssi3.shtml';
	o("GET /$ssi_exec HTTP/1.0\n\n",
		'ssi_begin.+Makefile.+ssi_end', 'SSI #exec');
	my $abs_path = on_windows() ? 'ssi6.shtml' : 'ssi5.shtml';
	my $word = on_windows() ? 'boot loader' : 'root';
	o("GET /$abs_path HTTP/1.0\n\n",
		"ssi_begin.+$word.+ssi_end", 'SSI #include file= (absolute)');
	o("GET /ssi7.shtml HTTP/1.0\n\n",
		'ssi_begin.+Unit test.+ssi_end', 'SSI #include "..."');
	o("GET /ssi8.shtml HTTP/1.0\n\n",
		'ssi_begin.+CFLAGS.+ssi_end', 'SSI nested #includes');

	# Manipulate the passwords file
	my $path = 'test_htpasswd';
	unlink $path;
	system("$exe -A $path a b c") == 0
		or fail("Cannot add user in a passwd file");
	system("$exe -A $path a b c2") == 0
		or fail("Cannot edit user in a passwd file");
	my $content = read_file($path);
	$content =~ /^b:a:\w+$/gs or fail("Bad content of the passwd file");
	unlink $path;

	kill_spawned_child();
	do_PUT_test();
	do_embedded_test();
}

sub do_PUT_test {
	$cmd .= ' -auth_PUT test/passfile';
	spawn($cmd);

	my $auth_header = "Authorization: Digest  username=guest, ".
		"realm=mydomain.com, nonce=1145872809, uri=/put.txt, ".
		"response=896327350763836180c61d87578037d9, qop=auth, ".
		"nc=00000002, cnonce=53eddd3be4e26a98\n";

	o("PUT /put.txt HTTP/1.0\nContent-Length: 7\n$auth_header\n1234567",
		"HTTP/1.1 201 OK", 'PUT file, status 201');
	fail("PUT content mismatch")
		unless read_file("$root/put.txt") eq '1234567';
	o("PUT /put.txt HTTP/1.0\nContent-Length: 4\n$auth_header\nabcd",
		"HTTP/1.1 200 OK", 'PUT file, status 200');
	fail("PUT content mismatch")
		unless read_file("$root/put.txt") eq 'abcd';
	o("PUT /put.txt HTTP/1.0\n$auth_header\nabcd",
		"HTTP/1.1 411 Length Required", 'PUT 411 error');
	o("PUT /put.txt HTTP/1.0\nExpect: blah\nContent-Length: 1\n".
		"$auth_header\nabcd",
		"HTTP/1.1 417 Expectation Failed", 'PUT 417 error');
	o("PUT /put.txt HTTP/1.0\nExpect: 100-continue\nContent-Length: 4\n".
		"$auth_header\nabcd",
		"HTTP/1.1 100 Continue.+HTTP/1.1 200", 'PUT 100-Continue');
	kill_spawned_child();
}

sub do_embedded_test {
	my $cmd = "cc -o $embed_exe $root/embed.c mongoose.c -I. ".
			"-DNO_SSL -lpthread -DLISTENING_PORT=\\\"$port\\\"";
	if (on_windows()) {
		$cmd = "cl $root/embed.c mongoose.c /I. /nologo ".
			"/DNO_SSL /DLISTENING_PORT=\\\"$port\\\" ".
			"/link /out:$embed_exe.exe ws2_32.lib ";
	}
	print $cmd, "\n";
	system($cmd) == 0 or fail("Cannot compile embedded unit test");

	spawn("./$embed_exe");
	o("GET /test_get_header HTTP/1.0\nHost: blah\n\n",
			'Value: \[blah\]', 'mg_get_header', 0);
	o("GET /test_get_var?a=b&my_var=foo&c=d HTTP/1.0\n\n",
			'Value: \[foo\]', 'mg_get_var 1', 0);
	o("GET /test_get_var?my_var=foo&c=d HTTP/1.0\n\n",
			'Value: \[foo\]', 'mg_get_var 2', 0);
	o("GET /test_get_var?a=b&my_var=foo HTTP/1.0\n\n",
			'Value: \[foo\]', 'mg_get_var 3', 0);
	o("POST /test_get_var HTTP/1.0\nContent-Length: 10\n\n".
		"my_var=foo", 'Value: \[foo\]', 'mg_get_var 4', 0);
	o("POST /test_get_var HTTP/1.0\nContent-Length: 18\n\n".
		"a=b&my_var=foo&c=d", 'Value: \[foo\]', 'mg_get_var 5', 0);
	o("POST /test_get_var HTTP/1.0\nContent-Length: 14\n\n".
		"a=b&my_var=foo", 'Value: \[foo\]', 'mg_get_var 6', 0);
	o("GET /test_get_var?a=one%2btwo&my_var=foo& HTTP/1.0\n\n",
			'Value: \[foo\]', 'mg_get_var 7', 0);
	o("GET /test_get_var?my_var=one%2btwo&b=two%2b HTTP/1.0\n\n",
			'Value: \[one\+two\]', 'mg_get_var 8', 0);

	# + in form data MUST be decoded to space
	o("POST /test_get_var HTTP/1.0\nContent-Length: 10\n\n".
		"my_var=b+c", 'Value: \[b c\]', 'mg_get_var 7', 0);

	# Test that big POSTed vars are not truncated
	my $my_var = 'x' x 64000;
	o("POST /test_get_var HTTP/1.0\nContent-Length: 64007\n\n".
		"my_var=$my_var", 'Value size: \[64000\]', 'mg_get_var 8', 0);

	# Test PUT
	o("PUT /put HTTP/1.0\nContent-Length: 3\n\nabc",
			'\nabc$', 'put callback', 0);

	o("POST /test_get_request_info?xx=yy HTTP/1.0\nFoo: bar\n".
		"Content-Length: 3\n\na=b",
		'Method: \[POST\].URI: \[/test_get_request_info\].'.
		'HTTP version: \[1/0\].HTTP header \[Foo\]: \[bar\].'.
		'HTTP header \[Content-Length\]: \[3\].'.
		'Query string: \[xx=yy\].POST data: \[a=b\].'.
		'Remote IP: \[\d+\].Remote port: \[\d+\].'.
		'Remote user: \[\]'
		, 'request_info', 0);
	o("GET /not_exist HTTP/1.0\n\n", 'Error: \[404\]', '404 handler', 0);
	o("bad request\n\n", 'Error: \[400\]', '* error handler', 0);
	o("GET /test_user_data HTTP/1.0\n\n",
		'User data: \[1234\]', 'user data in callback', 0);
#	o("GET /foo/secret HTTP/1.0\n\n",
#		'401 Unauthorized', 'mg_protect_uri', 0);
#	o("GET /foo/secret HTTP/1.0\nAuthorization: Digest username=bill\n\n",
#		'401 Unauthorized', 'mg_protect_uri (bill)', 0);
#	o("GET /foo/secret HTTP/1.0\nAuthorization: Digest username=joe\n\n",
#		'200 OK', 'mg_protect_uri (joe)', 0);

	# Test un-binding the URI
	o("GET /foo/bar HTTP/1.0\n\n", 'HTTP/1.1 200 OK', '/foo bound', 0);
	o("GET /test_remove_callback HTTP/1.0\n\n",
			'Removing callbacks', 'Callback removal', 0);
	o("GET /foo/bar HTTP/1.0\n\n", 'HTTP/1.1 404', '/foo unbound', 0);

	kill_spawned_child();
}

sub do_unit_test {
	my $cmd = "cc -o $unit_test_exe -DMONGOOSE_TEST $root/unit_test.c ".
		"-DDEBUG -I. -DNO_SSL -lpthread ";
	if (on_windows()) {
		$unit_test_exe .= '.exe';
		$cmd = "cl $root/unit_test.c /I. /nologo /DMONGOOSE_TEST ".
			"/DDEBUG /link /out:$unit_test_exe ws2_32.lib ";
	}
	print $cmd, "\n";
	system($cmd) == 0 or fail("Cannot compile unit test");
	system($unit_test_exe) == 0 or fail("Unit test failed");
}

print "SUCCESS! All tests passed.\n";
